home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr11.lha / clx / macros.lisp < prev    next >
Lisp/Scheme  |  1991-08-11  |  40KB  |  1,086 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. ;;; CLX basicly implements a very low overhead remote procedure call
  20. ;;; to the server.  This file contains macros which generate the code
  21. ;;; for both the client AND the server, given a specification of the
  22. ;;; interface. This was done to eliminate errors that may occur because
  23. ;;; the client and server code get/put bytes in different places, and
  24. ;;; it makes it easier to extend the protocol.
  25.  
  26. ;;; This is built on top of BUFFER
  27.  
  28. (in-package :xlib)
  29.  
  30. ;;; This variable is used by the required-arg macro just to satisfy compilers.
  31. (defvar *required-arg-dummy*)
  32.  
  33. ;;; An error signalling macro use to specify that keyword arguments are required.
  34. (defmacro required-arg (name)
  35.   `(progn (x-error 'missing-parameter :parameter ',name)
  36.       *required-arg-dummy*))
  37.  
  38. (defmacro lround (index)
  39.   ;; Round up to the next 32 bit boundary
  40.   `(the array-index (logand (index+ ,index 3) -4)))
  41.  
  42. (defmacro wround (index)
  43.   ;; Round up to the next 16 bit boundary
  44.   `(the array-index (logand (index+ ,index 1) -2)))
  45.  
  46. ;;
  47. ;; Data-type accessor functions
  48. ;;
  49. ;;   These functions translate between lisp data-types and the byte,
  50. ;;   half-word or word that gets transmitted across the client/server
  51. ;;   connection
  52.  
  53. (defun index-increment (type)
  54.   ;; Given a type, return its field width in bytes
  55.   (let* ((name (if (consp type) (car type) type))
  56.      (increment (get name 'byte-width :not-found)))
  57.     (when (eq increment :not-found)
  58.       ;; Check for TYPE in a different package
  59.       (when (not (eq (symbol-package name) *xlib-package*))
  60.     (setq name (xintern name))
  61.     (setq increment (get name 'byte-width :not-found)))
  62.       (when (eq increment :not-found)
  63.     (error "~s isn't a known field accessor" name)))
  64.     increment))
  65.  
  66. (eval-when (eval compile load)
  67. (defun getify (name)
  68.   (xintern name '-get))
  69.  
  70. (defun putify (name &optional predicate-p)
  71.   (xintern name '-put (if predicate-p '-predicating "")))
  72.  
  73.                     ;; Use &body so zmacs indents properly
  74. (defmacro define-accessor (name (width) &body get-put-macros)
  75.   ;; The first body form defines the get macro
  76.   ;; The second body form defines the put macro
  77.   ;; The third body form is optional, and defines a put macro that does
  78.   ;; type checking and does a put when ok, else NIL when the type is incorrect.
  79.   ;; If no third body form is present, then these macros assume that
  80.   ;; (AND (TYPEP ,thing 'type) (PUT-type ,thing)) can be generated.
  81.   ;; these predicating puts are used by the OR accessor.
  82.   (declare (arglist name (width) get-macro put-macro &optional predicating-put-macro))
  83.   (when (cdddr get-put-macros)
  84.     (error "Too many parameters to define-accessor: ~s" (cdddr get-put-macros)))
  85.   (let ((get-macro (or (first get-put-macros) (error "No GET macro form for ~s" name)))
  86.     (put-macro (or (second get-put-macros) (error "No PUT macro form for ~s" name))))
  87.     `(within-definition (,name define-accessor)
  88.        (setf (get ',name 'byte-width) ,(and width (floor width 8)))
  89.        (defmacro ,(getify name) ,(car get-macro)
  90.      ,@(cdr get-macro))
  91.        (defmacro ,(putify name) ,(car put-macro)
  92.      ,@(cdr put-macro))
  93.        ,@(when *type-check?*
  94.        (let ((predicating-put (third get-put-macros)))
  95.          (when predicating-put
  96.            `((setf (get ',name 'predicating-put) t)
  97.          (defmacro ,(putify name t) ,(car predicating-put)
  98.            ,@(cdr predicating-put)))))))))
  99. ) ;; End eval-when
  100.  
  101. (define-accessor card32 (32)
  102.   ((index) `(read-card32 ,index))
  103.   ((index thing) `(write-card32 ,index ,thing)))
  104.  
  105. (define-accessor card29 (32)
  106.   ((index) `(read-card29 ,index))
  107.   ((index thing) `(write-card29 ,index ,thing)))
  108.  
  109. (define-accessor card16 (16)
  110.   ((index) `(read-card16 ,index))
  111.   ((index thing) `(write-card16 ,index ,thing)))
  112.  
  113. (define-accessor card8 (8)
  114.   ((index) `(read-card8 ,index))
  115.   ((index thing) `(write-card8 ,index ,thing)))
  116.  
  117. (define-accessor integer (32)
  118.   ((index) `(read-int32 ,index))
  119.   ((index thing) `(write-int32 ,index ,thing)))
  120.  
  121. (define-accessor int16 (16)
  122.   ((index) `(read-int16 ,index))
  123.   ((index thing) `(write-int16 ,index ,thing)))
  124.  
  125. (define-accessor rgb-val (16)
  126.   ;; Used for color's
  127.   ((index) `(card16->rgb-val (read-card16 ,index)))
  128.   ((index thing) `(write-card16 ,index (rgb-val->card16 ,thing))))
  129.  
  130. (define-accessor angle (16)
  131.   ;; Used for drawing arcs
  132.   ((index) `(int16->radians (read-int16 ,index)))
  133.   ((index thing) `(write-int16 ,index (radians->int16 ,thing))))
  134.  
  135. (define-accessor bit (0)
  136.   ;; Like BOOLEAN, but tests bits
  137.   ;; only used by declare-event (:enter-notify :leave-notify)
  138.   ((index bit)
  139.    `(logbitp ,bit (read-card8 ,index)))
  140.   ((index thing bit)
  141.    (if (zerop bit)
  142.        `(write-card8 ,index (if ,thing 1 0))
  143.      `(write-card8 ,index (dpb (if ,thing 1 0) (byte 1 ,bit) (read-card8 ,index))))))
  144.  
  145. (define-accessor boolean (8)
  146.   ((index)
  147.    `(plusp (read-card8 ,index)))
  148.   ((index thing) `(write-card8 ,index (if ,thing 1 0))))
  149.  
  150. (define-accessor drawable (32)
  151.   ((index &optional (buffer '%buffer))
  152.    `(lookup-drawable ,buffer (read-card29 ,index)))
  153.   ((index thing) `(write-card29 ,index (drawable-id ,thing))))
  154.  
  155. (define-accessor window (32)
  156.   ((index &optional (buffer '%buffer))
  157.    `(lookup-window ,buffer (read-card29 ,index)))
  158.   ((index thing) `(write-card29 ,index (window-id ,thing))))
  159.  
  160. (define-accessor pixmap (32)
  161.   ((index &optional (buffer '%buffer))
  162.    `(lookup-pixmap ,buffer (read-card29 ,index)))
  163.   ((index thing) `(write-card29 ,index (pixmap-id ,thing))))
  164.  
  165. (define-accessor gcontext (32)
  166.   ((index &optional (buffer '%buffer))
  167.    `(lookup-gcontext ,buffer (read-card29 ,index)))
  168.   ((index thing) `(write-card29 ,index (gcontext-id ,thing))))
  169.  
  170. (define-accessor cursor (32)
  171.   ((index &optional (buffer '%buffer))
  172.    `(lookup-cursor ,buffer (read-card29 ,index)))
  173.   ((index thing) `(write-card29 ,index (cursor-id ,thing))))
  174.  
  175. (define-accessor colormap (32)
  176.   ((index &optional (buffer '%buffer))
  177.    `(lookup-colormap ,buffer (read-card29 ,index)))
  178.   ((index thing) `(write-card29 ,index (colormap-id ,thing))))
  179.  
  180. (define-accessor font (32)
  181.   ((index &optional (buffer '%buffer))
  182.    `(lookup-font ,buffer (read-card29 ,index)))
  183.   ;; The FONT-ID accessor may make a OpenFont request.  Since we don't support recursive
  184.   ;; with-buffer-request, issue a compile time error, rather than barf at run-time.
  185.   ((index thing)
  186.    (declare (ignore index thing))
  187.    (error "FONT-ID must be called OUTSIDE with-buffer-request.  Use RESOURCE-ID instead.")))
  188.  
  189. ;; Needed to get and put xatom's in events
  190. (define-accessor keyword (32)
  191.   ((index &optional (buffer '%buffer))
  192.    `(atom-name ,buffer (read-card29 ,index)))
  193.   ((index thing &key (buffer '%buffer))
  194.    `(write-card29 ,index (or (atom-id ,thing ,buffer)
  195.                  (error "CLX implementation error in KEYWORD-PUT")))))
  196.  
  197. (define-accessor resource-id (32)
  198.   ((index) `(read-card29 ,index))
  199.   ((index thing) `(write-card29 ,index ,thing)))
  200.  
  201. (define-accessor resource-id-or-nil (32)
  202.   ((index) (let ((id (gensym)))
  203.          `(let ((,id (read-card29 ,index)))
  204.         (and (plusp ,id) ,id))))
  205.   ((index thing) `(write-card29 ,index (or ,thing 0))))
  206.  
  207. (defmacro char-info-get (index)
  208.   `(make-char-info
  209.      :left-bearing (int16-get ,index)
  210.      :right-bearing (int16-get ,(+ index 2))
  211.      :width       (int16-get ,(+ index 4))
  212.      :ascent       (int16-get ,(+ index 6))
  213.      :descent       (int16-get ,(+ index 8))
  214.      :attributes   (card16-get ,(+ index 10))))
  215.  
  216. (define-accessor member8 (8)
  217.   ((index &rest keywords)
  218.    (let ((value (gensym)))
  219.      `(let ((,value (read-card8 ,index)))
  220.     (and (< ,value ,(length keywords))
  221.          (svref ',(apply #'vector keywords) ,value)))))
  222.   ((index thing &rest keywords)
  223.    `(write-card8 ,index (position ,thing
  224.                   #+lispm ',keywords ;; Lispm's prefer lists
  225.                   #-lispm (the simple-vector ',(apply #'vector keywords))
  226.                   :test #'eq)))
  227.   ((index thing &rest keywords)
  228.    (let ((value (gensym)))
  229.      `(let ((,value (position ,thing
  230.                   #+lispm ',keywords
  231.                   #-lispm (the simple-vector ',(apply #'vector keywords))
  232.                   :test #'eq)))
  233.     (and ,value (write-card8 ,index ,value))))))
  234.  
  235. (define-accessor member16 (16)
  236.   ((index &rest keywords)
  237.    (let ((value (gensym)))
  238.      `(let ((,value (read-card16 ,index)))
  239.     (and (< ,value ,(length keywords))
  240.          (svref ',(apply #'vector keywords) ,value)))))
  241.   ((index thing &rest keywords)
  242.    `(write-card16 ,index (position ,thing
  243.                    #+lispm ',keywords ;; Lispm's prefer lists
  244.                    #-lispm (the simple-vector ',(apply #'vector keywords))
  245.                    :test #'eq)))
  246.   ((index thing &rest keywords)
  247.    (let ((value (gensym)))
  248.      `(let ((,value (position ,thing
  249.                   #+lispm ',keywords
  250.                   #-lispm (the simple-vector ',(apply #'vector keywords))
  251.                   :test #'eq)))
  252.     (and ,value (write-card16 ,index ,value))))))
  253.  
  254. (define-accessor member (32)
  255.   ((index &rest keywords)
  256.    (let ((value (gensym)))
  257.      `(let ((,value (read-card29 ,index)))
  258.     (and (< ,value ,(length keywords))
  259.          (svref ',(apply #'vector keywords) ,value)))))
  260.   ((index thing &rest keywords)
  261.    `(write-card29 ,index (position ,thing
  262.                    #+lispm ',keywords ;; Lispm's prefer lists
  263.                    #-lispm (the simple-vector ',(apply #'vector keywords))
  264.                    :test #'eq)))
  265.   ((index thing &rest keywords)
  266.    (if (cdr keywords) ;; IF more than one
  267.        (let ((value (gensym)))
  268.      `(let ((,value (position ,thing
  269.                    #+lispm ',keywords
  270.                    #-lispm (the simple-vector ',(apply #'vector keywords))
  271.                   :test #'eq)))
  272.         (and ,value (write-card29 ,index ,value))))
  273.      `(and (eq ,thing ,(car keywords)) (write-card29 ,index 0)))))
  274.  
  275. (deftype member-vector (vector) `(member ,@(coerce (symbol-value vector) 'list)))
  276.  
  277. (define-accessor member-vector (32)
  278.   ((index membership-vector)
  279.    `(member-get ,index ,@(coerce (eval membership-vector) 'list)))
  280.   ((index thing membership-vector)
  281.    `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))
  282.   ((index thing membership-vector)
  283.    `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list))))
  284.  
  285. (define-accessor member16-vector (16)
  286.   ((index membership-vector)
  287.    `(member16-get ,index ,@(coerce (eval membership-vector) 'list)))
  288.   ((index thing membership-vector)
  289.    `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))
  290.   ((index thing membership-vector)
  291.    `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list))))
  292.  
  293. (define-accessor member8-vector (8)
  294.   ((index membership-vector)
  295.    `(member8-get ,index ,@(coerce (eval membership-vector) 'list)))
  296.   ((index thing membership-vector)
  297.    `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))
  298.   ((index thing membership-vector)
  299.    `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list))))
  300.  
  301. (define-accessor boole-constant (32)
  302.   ;; this isn't member-vector because we need eql instead of eq
  303.   ((index)
  304.    (let ((value (gensym)))
  305.      `(let ((,value (read-card29 ,index)))
  306.     (and (< ,value ,(length *boole-vector*))
  307.          (svref *boole-vector* ,value)))))
  308.   ((index thing)
  309.    `(write-card29 ,index (position ,thing (the simple-vector *boole-vector*))))
  310.   ((index thing)
  311.    (let ((value (gensym)))
  312.      `(let ((,value (position ,thing (the simple-vector *boole-vector*))))
  313.     (and ,value (write-card29 ,index ,value))))))
  314.  
  315. (define-accessor null (32)
  316.   ((index) `(if (zerop (read-card32 ,index)) nil (read-card32 ,index)))
  317.   ((index value) (declare (ignore value)) `(write-card32 ,index 0)))
  318.  
  319. (define-accessor pad8 (8)
  320.   ((index) (declare (ignore index)) nil)
  321.   ((index value) (declare (ignore index value))  nil))
  322.  
  323. (define-accessor pad16 (16)
  324.   ((index) (declare (ignore index)) nil)
  325.   ((index value) (declare (ignore index value)) nil))
  326.  
  327. (define-accessor bit-vector256 (256)
  328.   ;; used for key-maps
  329.   ;; REAL-INDEX parameter provided so the default index can be over-ridden.
  330.   ;; This is needed for the :keymap-notify event where the keymap overlaps
  331.   ;; the window id.
  332.   ((index &optional (real-index index) data)
  333.    `(read-bitvector256 buffer-bbuf ,real-index ,data))
  334.   ((index map &optional (real-index index) (buffer '%buffer))
  335.    `(write-bitvector256 ,buffer (index+ buffer-boffset ,real-index) ,map)))
  336.    
  337. (define-accessor string (nil)
  338.   ((length index &key reply-buffer)
  339.    `(read-sequence-char
  340.       ,(or reply-buffer '%reply-buffer) 'string ,length nil nil 0 ,index))
  341.   ((index string &key buffer (start 0) end header-length appending)
  342.    (unless buffer (setq buffer '%buffer))
  343.    (unless header-length (setq header-length (lround index)))
  344.    (let* ((real-end (if appending (or end `(length ,string)) (gensym)))
  345.       (form `(write-sequence-char ,buffer (index+ buffer-boffset ,header-length)
  346.                       ,string ,start ,real-end)))
  347.      (if appending
  348.      form
  349.        `(let ((,real-end ,(or end `(length ,string))))
  350.       (write-card16 2 (index-ceiling (index+ (index- ,real-end ,start) ,header-length) 4))
  351.       ,form)))))
  352.  
  353. (define-accessor sequence (nil)
  354.   ((&key length (format 'card32) result-type transform reply-buffer data index start)
  355.    `(,(ecase format
  356.     (card8 'read-sequence-card8)
  357.     (int8 'read-sequence-int8)
  358.     (card16 'read-sequence-card16)
  359.     (int16 'read-sequence-int16)
  360.     (card32 'read-sequence-card32)
  361.     (int32 'read-sequence-int32))
  362.      ,(or reply-buffer '%reply-buffer)
  363.      ,result-type ,length ,transform ,data
  364.      ,@(when (or start index) `(,(or start 0)))
  365.      ,@(when index `(,index))))
  366.   ((index data &key (format 'card32) (start 0) end transform buffer appending)
  367.    (unless buffer (setq buffer '%buffer))
  368.    (let* ((real-end (if appending (or end `(length ,data)) (gensym)))
  369.       (writer (xintern 'write-sequence- format))
  370.       (form `(,writer ,buffer (index+ buffer-boffset ,(lround index))
  371.           ,data ,start ,real-end ,transform)))
  372.      (flet ((maker (size)
  373.           (if appending
  374.           form
  375.           (let ((idx `(index- ,real-end ,start)))
  376.             (unless (= size 1)
  377.               (setq idx `(index-ceiling ,idx ,size)))
  378.             `(let ((,real-end ,(or end `(length ,data))))
  379.                (write-card16 2 (index+ ,idx ,(index-ceiling index 4)))
  380.                ,form)))))
  381.        (ecase format
  382.      ((card8 int8)
  383.       (maker 4))
  384.      ((card16 int16 char2b)
  385.       (maker 2))
  386.      ((card32 int32)
  387.       (maker 1)))))))
  388.  
  389. (defmacro client-message-event-get-sequence ()
  390.   '(let* ((format (read-card8 1))
  391.        (sequence (make-array (ceiling 160 format)
  392.                 :element-type `(unsigned-byte ,format))))
  393.      (do ((i 12)
  394.       (j 0 (1+ j)))
  395.      ((>= i 32))
  396.        (case format
  397.      (8 (setf (aref sequence j) (read-card8 i))
  398.         (incf i))
  399.      (16 (setf (aref sequence j) (read-card16 i))
  400.          (incf i 2))
  401.      (32 (setf (aref sequence j) (read-card32 i))
  402.          (incf i 4))))
  403.      sequence))
  404.  
  405. (defmacro client-message-event-put-sequence (format sequence)
  406.   `(ecase ,format
  407.      (8  (sequence-put 12 ,sequence
  408.                :format card8
  409.                :end (min (length ,sequence) 20)
  410.                :appending t))
  411.      (16 (sequence-put 12 ,sequence
  412.                :format card16
  413.                :end (min (length ,sequence) 10)
  414.                :appending t))
  415.      (32 (sequence-put 12 ,sequence
  416.                :format card32
  417.                :end (min (length ,sequence) 5)
  418.                :appending t))))
  419.  
  420. ;; Used only in declare-event
  421. (define-accessor client-message-sequence (160)
  422.   ((index format) (declare (ignore index format)) `(client-message-event-get-sequence))
  423.   ((index value format) (declare (ignore index))
  424.    `(client-message-event-put-sequence ,format ,value)))
  425.  
  426.  
  427. ;;;
  428. ;;; Compound accessors
  429. ;;;    Accessors that take other accessors as parameters
  430. ;;;
  431. (define-accessor code (0)
  432.   ((index) (declare (ignore index)) '(read-card8 0))
  433.   ((index value) (declare (ignore index)) `(write-card8 0 ,value))
  434.   ((index value) (declare (ignore index)) `(write-card8 0 ,value)))
  435.  
  436. (define-accessor length (0)
  437.   ((index) (declare (ignore index)) '(read-card16 2))
  438.   ((index value) (declare (ignore index)) `(write-card16 2 ,value))
  439.   ((index value) (declare (ignore index)) `(write-card16 2 ,value)))
  440.  
  441. (deftype data () 'card8)
  442.  
  443. (define-accessor data (0)
  444.   ;; Put data in byte 1 of the reqeust
  445.   ((index &optional stuff) (declare (ignore index))
  446.    (if stuff
  447.        (if (consp stuff)
  448.        `(,(getify (car stuff)) 1 ,@(cdr stuff))
  449.      `(,(getify stuff) 1))
  450.      `(read-card8 1)))
  451.   ((index thing &optional stuff)
  452.    (if stuff
  453.        (if (consp stuff)
  454.        `(macrolet ((write-card32 (index value) index value))
  455.           (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff))))
  456.      `(,(putify stuff) 1 ,thing))
  457.      `(write-card8 1 ,thing)))
  458.   ((index thing &optional stuff)
  459.    (if stuff
  460.        `(and (type? ,thing ',stuff)
  461.          ,(if (consp stuff)
  462.           `(macrolet ((write-card32 (index value) index value))
  463.              (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff))))
  464.         `(,(putify stuff) 1 ,thing)))
  465.      `(and (type? ,thing 'card8) (write-card8 1 ,thing)))))
  466.  
  467. ;; Macroexpand the result of OR-GET to allow the macros file to not be loaded
  468. ;; when using event-case.  This is pretty gross.
  469.  
  470. (defmacro or-expand (&rest forms &environment environment)
  471.   `(cond ,@(mapcar #'(lambda (forms)
  472.                (mapcar #'(lambda (form)
  473.                    (macroexpand form environment))
  474.                    forms))
  475.            forms)))
  476.  
  477. ;;
  478. ;; the OR type
  479. ;;
  480. (define-accessor or (32)
  481.   ;; Select from among several types (usually NULL and something else)
  482.   ((index &rest type-list &environment environment)
  483.    (do ((types type-list (cdr types))
  484.     (value (gensym))
  485.     (result))
  486.        ((endp types)
  487.     `(let ((,value (read-card32 ,index)))
  488.        (macrolet ((read-card32 (index) index ',value)
  489.               (read-card29 (index) index ',value))
  490.          ,(macroexpand `(or-expand ,@(nreverse result)) environment))))
  491.      (let ((item (car types))
  492.        (args nil))
  493.        (when (consp item)
  494.      (setq args (cdr item)
  495.            item (car item)))
  496.        (if (eq item 'null)  ;; Special case for NULL
  497.        (push `((zerop ,value) nil) result)
  498.      (push
  499.        `((,(getify item) ,index ,@args))
  500.        result)))))
  501.  
  502.   ((index value &rest type-list)
  503.    (do ((types type-list (cdr types))
  504.     (result))
  505.        ((endp types)
  506.     `(cond ,@(nreverse result)
  507.            ,@(when *type-check?*
  508.            `((t (x-type-error ,value '(or ,@type-list)))))))
  509.      (let* ((type (car types))
  510.         (type-name type)
  511.         (args nil))
  512.        (when (consp type)
  513.      (setq args (cdr type)
  514.            type-name (car type)))
  515.        (push
  516.      `(,@(cond ((get type-name 'predicating-put) nil)
  517.            ((or *type-check?* (cdr types)) `((type? ,value ',type)))
  518.            (t '(t)))
  519.        (,(putify type-name (get type-name 'predicating-put)) ,index ,value ,@args))
  520.      result)))))
  521.  
  522. ;;
  523. ;; the MASK type...
  524. ;;     is used to specify a subset of a collection of "optional" arguments.
  525. ;;     A mask type consists of a 32 bit mask word followed by a word for each one-bit
  526. ;;     in the mask.  The MASK type is ALWAYS the LAST item in a request.
  527. ;;
  528. (setf (get 'mask 'byte-width) nil)
  529.  
  530. (defun mask-get (index type-values body-function)
  531.   (declare (type function body-function)
  532.        #+clx-ansi-common-lisp
  533.        (dynamic-extent body-function)
  534.        #+(and lispm (not clx-ansi-common-lisp))
  535.        (sys:downward-funarg body-function))
  536.   ;; This is a function, because it must return more than one form (called by get-put-items)
  537.   ;; Functions that use this must have a binding for %MASK
  538.   (let* ((bit 0)
  539.      (result
  540.        (mapcar
  541.          #'(lambda (form)
  542.          (if (atom form)
  543.              form ;; Hack to allow BODY-FUNCTION to return keyword/value pairs
  544.            (prog1
  545.              `(when (logbitp ,bit %mask)
  546.             ;; Execute form when bit is set
  547.             ,form)
  548.              (incf bit))))
  549.          (get-put-items
  550.            (+ index 4) type-values nil
  551.            #'(lambda (type index item args)
  552.            (declare (ignore index))
  553.            (funcall body-function type '(* (incf %index) 4) item args))))))
  554.     ;; First form must load %MASK
  555.     `(,@(when (atom (car result))
  556.       (list (pop result)))
  557.       (progn (setq %mask (read-card32 ,index))
  558.          (setq %index ,(ceiling index 4))
  559.          ,(car result))
  560.       ,@(cdr result))))
  561.  
  562. ;; MASK-PUT 
  563.  
  564. (defun mask-put (index type-values body-function)
  565.   (declare (type function body-function)
  566.        #+clx-ansi-common-lisp
  567.        (dynamic-extent body-function)
  568.        #+(and lispm (not clx-ansi-common-lisp))
  569.        (sys:downward-funarg body-function))
  570.   ;; The MASK type writes a 32 bit mask with 1 bits for each non-nil value in TYPE-VALUES
  571.   ;; A 32 bit value follows for each non-nil value.
  572.   `((let ((%mask 0)
  573.       (%index ,index))
  574.       ,@(let ((bit 1))
  575.       (get-put-items
  576.         index type-values t 
  577.         #'(lambda (type index item args)
  578.         (declare (ignore index))
  579.         (if (or (symbolp item) (constantp item))
  580.             `((unless (null ,item)
  581.             (setq %mask (logior %mask ,(shiftf bit (ash bit 1))))
  582.             ,@(funcall body-function type
  583.                    `(index-incf %index 4) item args)))
  584.           `((let ((.item. ,item))
  585.               (unless (null .item.)
  586.             (setq %mask (logior %mask ,(shiftf bit (ash bit 1))))
  587.             ,@(funcall body-function type
  588.                    `(index-incf %index 4) '.item. args))))))))
  589.       (write-card32 ,index %mask)
  590.       (write-card16 2 (index-ceiling (index-incf %index 4) 4))
  591.       (incf (buffer-boffset %buffer) %index))))
  592.  
  593. (define-accessor progn (nil)
  594.   ;; Catch-all for inserting random code
  595.   ;; Note that code using this is then responsible for setting the request length
  596.   ((index statement) (declare (ignore index)) statement)
  597.   ((index statement) (declare (ignore index)) statement))
  598.  
  599.  
  600. ;
  601. ; Wrapper macros, for use around the above
  602. ;
  603. (defmacro type-check (value type)
  604.   value type
  605.   (when *type-check?*
  606.     `(unless (type? ,value ,type)
  607.        (x-type-error ,value ,type))))
  608.  
  609. (defmacro check-put (index value type &rest args &environment env)
  610.   (let* ((var (if (or (symbolp value) (constantp value)) value '.value.))
  611.      (body
  612.        (if (or (null (macroexpand `(type-check ,var ',type) env))
  613.            (member type '(or progn pad8 pad16))
  614.            (constantp value))
  615.            `(,(putify type) ,index ,var ,@args)
  616.          ;; Do type checking
  617.          (if (get type 'predicating-put)
  618.          `(or (,(putify type t) ,index ,var ,@args)
  619.               (x-type-error ,var ',(if args `(,type ,@args) type)))
  620.            `(if (type? ,var ',type)
  621.             (,(putify type) ,index ,var ,@args)
  622.           (x-type-error ,var ',(if args `(,type ,@args) type)))))))
  623.     (if (eq var value)
  624.     body
  625.       `(let ((,var ,value))
  626.      ,body))))
  627.  
  628. (defun get-put-items (index type-args putp &optional body-function)
  629.   (declare (type (or null function) body-function)
  630.        #+clx-ansi-common-lisp
  631.        (dynamic-extent body-function)
  632.        #+(and lispm (not clx-ansi-common-lisp))
  633.        (sys:downward-funarg body-function))
  634.   ;; Given a lists of the form (type item item ... item)
  635.   ;; Calls body-function with four arguments, a function name,
  636.   ;; index, item name, and optional arguments.
  637.   ;; The results are appended together and retured.
  638.   (unless body-function
  639.     (setq body-function
  640.       #'(lambda (type index item args)
  641.           `((check-put ,index ,item ,type ,@args)))))
  642.   (do* ((items type-args (cdr items))
  643.     (type (caar items) (caar items))
  644.     (args nil nil)
  645.     (result nil)
  646.     (sizes nil))
  647.        ((endp items) (values result index sizes))
  648.     (when (consp type)
  649.       (setq args (cdr type)
  650.         type (car type)))
  651.     (cond ((member type '(return buffer)))
  652.       ((eq type 'mask) ;; Hack to enable mask-get/put to return multiple values
  653.        (setq result
  654.          (append result (if putp
  655.                     (mask-put index (cdar items) body-function)
  656.                   (mask-get index (cdar items) body-function)))
  657.          index nil))
  658.       (t (do* ((item (cdar items) (cdr item))
  659.            (increment (index-increment type)))
  660.           ((endp item))
  661.            (when (constantp index)
  662.          (case increment        ;Round up index when needed
  663.            (2 (setq index (wround index)))
  664.            (4 (setq index (lround index)))))
  665.            (setq result
  666.              (append result (funcall body-function type index (car item) args)))
  667.            (when (constantp index)
  668.          ;; Variable length requests have null length increment.
  669.          ;; Variable length requests set the request size 
  670.          ;; & maintain buffer pointers
  671.          (if (null increment) 
  672.              (setq index nil)
  673.            (progn
  674.              (incf index increment)
  675.              (when (and increment (zerop increment)) (setq increment 1))
  676.              (pushnew (* increment 8) sizes)))))))))
  677.  
  678. (defmacro with-buffer-request-internal
  679.       ((buffer opcode &key length sizes &allow-other-keys)
  680.        &body type-args)
  681.   (multiple-value-bind (code index item-sizes)
  682.       (get-put-items 4 type-args t)
  683.     (let ((length (if length `(index+ ,length *requestsize*) '*requestsize*))
  684.       (sizes (remove-duplicates (append '(8 16) item-sizes sizes))))
  685.       `(with-buffer-output (,buffer :length ,length :sizes ,sizes)
  686.      (setf (buffer-last-request ,buffer) buffer-boffset)
  687.      (write-card8 0 ,opcode)       ;; Stick in the opcode
  688.      ,@code
  689.      ,@(when index
  690.          (setq index (lround index))
  691.          `((write-card16 2 ,(ceiling index 4))
  692.            (setf (buffer-boffset ,buffer) (index+ buffer-boffset ,index))))
  693.      (buffer-new-request-number ,buffer)))))
  694.  
  695. (defmacro with-buffer-request
  696.       ((buffer opcode &rest options &key inline gc-force &allow-other-keys)
  697.        &body type-args &environment env)
  698.   (if (and (null inline) (macroexpand '(use-closures) env))
  699.       `(flet ((.request-body. (.display.)
  700.         (declare (type display .display.))
  701.         (with-buffer-request-internal (.display. ,opcode ,@options)
  702.           ,@type-args)))
  703.      #+clx-ansi-common-lisp
  704.      (declare (dynamic-extent #'.request-body.))
  705.      (,(if (eq (car (macroexpand '(with-buffer (buffer)) env)) 'progn)
  706.            'with-buffer-request-function-nolock
  707.          'with-buffer-request-function)
  708.       ,buffer ,gc-force #'.request-body.))
  709.     `(let ((.display. ,buffer))
  710.        (declare (type display .display.))
  711.        (with-buffer (.display.)
  712.      ,@(when gc-force `((force-gcontext-changes-internal ,gc-force)))
  713.      (multiple-value-prog1
  714.        (without-aborts 
  715.          (with-buffer-request-internal (.display. ,opcode ,@options)
  716.            ,@type-args))
  717.        (display-invoke-after-function .display.))))))
  718.  
  719. (defmacro with-buffer-request-and-reply
  720.       ((buffer opcode reply-size &key sizes multiple-reply inline)
  721.        type-args &body reply-forms &environment env)
  722.   (declare (indentation 0 4 1 4 2 1))
  723.   (let* ((inner-reply-body
  724.        `(with-buffer-input (.reply-buffer. :display .display.
  725.                            ,@(and sizes (list :sizes sizes)))
  726.           nil ,@reply-forms))
  727.      (reply-body
  728.        (if (or (not (symbolp reply-size)) (constantp reply-size))
  729.            inner-reply-body
  730.          `(let ((,reply-size (reply-data-size (the reply-buffer .reply-buffer.))))
  731.         (declare (type array-index ,reply-size))
  732.         ,inner-reply-body))))
  733.     (if (and (null inline) (macroexpand '(use-closures) env))
  734.     `(flet ((.request-body. (.display.)
  735.           (declare (type display .display.))
  736.           (with-buffer-request-internal (.display. ,opcode)
  737.             ,@type-args))
  738.         (.reply-body. (.display. .reply-buffer.)
  739.           (declare (type display .display.)
  740.                (type reply-buffer .reply-buffer.))
  741.           (progn .display. .reply-buffer. nil)
  742.           ,reply-body))
  743.        #+clx-ansi-common-lisp
  744.        (declare (dynamic-extent #'.request-body. #'.reply-body.))
  745.        (with-buffer-request-and-reply-function
  746.          ,buffer ,multiple-reply #'.request-body. #'.reply-body.))
  747.       `(let ((.display. ,buffer)
  748.          (.pending-command. nil)
  749.          (.reply-buffer. nil))
  750.      (declare (type display .display.)
  751.           (type (or null pending-command) .pending-command.)
  752.           (type (or null reply-buffer) .reply-buffer.))
  753.      (unwind-protect
  754.          (progn 
  755.            (with-buffer (.display.)
  756.          (setq .pending-command. (start-pending-command .display.))
  757.          (without-aborts
  758.            (with-buffer-request-internal (.display. ,opcode)
  759.              ,@type-args))
  760.          (buffer-force-output .display.)
  761.          (display-invoke-after-function .display.))
  762.            ,@(if multiple-reply
  763.              `((loop
  764.              (setq .reply-buffer. (read-reply .display. .pending-command.))
  765.              (when ,reply-body (return nil))
  766.              (deallocate-reply-buffer (shiftf .reply-buffer. nil))))
  767.            `((setq .reply-buffer. (read-reply .display. .pending-command.))
  768.              ,reply-body)))
  769.        (when .reply-buffer.
  770.          (deallocate-reply-buffer .reply-buffer.))
  771.        (when .pending-command.
  772.          (stop-pending-command .display. .pending-command.)))))))
  773.  
  774. (defmacro compare-request ((index) &body body)
  775.   `(macrolet ((write-card32 (index item) `(= ,item (read-card32 ,index)))
  776.           (write-int32 (index item) `(= ,item (read-int32 ,index)))
  777.           (write-card29 (index item) `(= ,item (read-card29 ,index)))
  778.           (write-int29 (index item) `(= ,item (read-int29 ,index)))
  779.           (write-card16 (index item) `(= ,item (read-card16 ,index)))
  780.           (write-int16 (index item) `(= ,item (read-int16 ,index)))
  781.           (write-card8 (index item) `(= ,item (read-card8 ,index)))
  782.           (write-int8 (index item) `(= ,item (read-int8 ,index))))
  783.      (macrolet ((type-check (value type) value type nil))
  784.        (and ,@(get-put-items index body t)))))
  785.  
  786. (defmacro put-items ((index) &body body)
  787.   `(progn ,@(get-put-items index body t)))
  788.  
  789. (defmacro decode-type (type value)
  790.   ;; Given an integer and type, return the value
  791.   (let ((args nil))
  792.     (when (consp type)
  793.       (setq args (cdr type)
  794.         type (car type)))
  795.     `(macrolet ((read-card29 (value) value)
  796.         (read-card32 (value) value)
  797.         (read-int32 (value) `(card32->int32 ,value))
  798.         (read-card16 (value) value)
  799.         (read-int16 (value) `(card16->int16 ,value))
  800.         (read-card8 (value) value)
  801.         (read-int8 (value) `(int8->card8 ,value)))
  802.        (,(getify type) ,value ,@args))))
  803.  
  804. (defmacro encode-type (type value)
  805.   ;; Given a value and type, return an integer
  806.   ;; When check-p, do type checking on value
  807.   (let ((args nil))
  808.     (when (consp type)
  809.       (setq args (cdr type)
  810.         type (car type)))
  811.     `(macrolet ((write-card29 (index value) index value)
  812.         (write-card32 (index value) index value)
  813.         (write-int32 (index value) index `(int32->card32 ,value))
  814.         (write-card16 (index value) index value)
  815.         (write-int16 (index value) index `(int16->card16 ,value))
  816.         (write-card8 (index value) index value)
  817.         (write-int8 (index value) index `(int8->card8 ,value)))
  818.        (check-put 0 ,value ,type ,@args))))
  819.  
  820. (defmacro set-decode-type (type accessor value)
  821.   `(setf ,accessor (encode-type ,type ,value)))
  822. (defsetf decode-type set-decode-type)
  823.  
  824.  
  825. ;;;
  826. ;;; Request codes
  827. ;;; 
  828.  
  829. (defconstant *x-createwindow*                  1)
  830. (defconstant *x-changewindowattributes*        2)
  831. (defconstant *x-getwindowattributes*           3)
  832. (defconstant *x-destroywindow*                 4)
  833. (defconstant *x-destroysubwindows*             5)  
  834. (defconstant *x-changesaveset*                 6)
  835. (defconstant *x-reparentwindow*                7)
  836. (defconstant *x-mapwindow*                     8)
  837. (defconstant *x-mapsubwindows*                 9)
  838. (defconstant *x-unmapwindow*                  10)
  839. (defconstant *x-unmapsubwindows*              11) 
  840. (defconstant *x-configurewindow*              12)
  841. (defconstant *x-circulatewindow*              13)
  842. (defconstant *x-getgeometry*                  14)
  843. (defconstant *x-querytree*                    15)
  844. (defconstant *x-internatom*                   16)
  845. (defconstant *x-getatomname*                  17)
  846. (defconstant *x-changeproperty*               18)
  847. (defconstant *x-deleteproperty*               19)
  848. (defconstant *x-getproperty*                  20)
  849. (defconstant *x-listproperties*               21)
  850. (defconstant *x-setselectionowner*            22)  
  851. (defconstant *x-getselectionowner*            23) 
  852. (defconstant *x-convertselection*             24)
  853. (defconstant *x-sendevent*                    25)
  854. (defconstant *x-grabpointer*                  26)
  855. (defconstant *x-ungrabpointer*                27)
  856. (defconstant *x-grabbutton*                   28)
  857. (defconstant *x-ungrabbutton*                 29)
  858. (defconstant *x-changeactivepointergrab*      30)         
  859. (defconstant *x-grabkeyboard*                 31)
  860. (defconstant *x-ungrabkeyboard*               32)
  861. (defconstant *x-grabkey*                      33)
  862. (defconstant *x-ungrabkey*                    34)
  863. (defconstant *x-allowevents*                  35)
  864. (defconstant *x-grabserver*                   36)     
  865. (defconstant *x-ungrabserver*                 37)       
  866. (defconstant *x-querypointer*                 38)       
  867. (defconstant *x-getmotionevents*              39)          
  868. (defconstant *x-translatecoords*              40)               
  869. (defconstant *x-warppointer*                  41)      
  870. (defconstant *x-setinputfocus*                42)        
  871. (defconstant *x-getinputfocus*                43)        
  872. (defconstant *x-querykeymap*                  44)      
  873. (defconstant *x-openfont*                     45)   
  874. (defconstant *x-closefont*                    46)    
  875. (defconstant *x-queryfont*                    47)
  876. (defconstant *x-querytextextents*             48)    
  877. (defconstant *x-listfonts*                    49) 
  878. (defconstant *x-listfontswithinfo*              50)
  879. (defconstant *x-setfontpath*                  51)
  880. (defconstant *x-getfontpath*                  52)
  881. (defconstant *x-createpixmap*                 53)      
  882. (defconstant *x-freepixmap*                   54)   
  883. (defconstant *x-creategc*                     55)
  884. (defconstant *x-changegc*                     56)
  885. (defconstant *x-copygc*                       57)
  886. (defconstant *x-setdashes*                    58)  
  887. (defconstant *x-setcliprectangles*            59)         
  888. (defconstant *x-freegc*                       60)
  889. (defconstant *x-cleartobackground*            61)          
  890. (defconstant *x-copyarea*                     62)
  891. (defconstant *x-copyplane*                    63)
  892. (defconstant *x-polypoint*                    64)
  893. (defconstant *x-polyline*                     65)
  894. (defconstant *x-polysegment*                  66)  
  895. (defconstant *x-polyrectangle*                67)   
  896. (defconstant *x-polyarc*                      68)
  897. (defconstant *x-fillpoly*                     69)
  898. (defconstant *x-polyfillrectangle*            70)        
  899. (defconstant *x-polyfillarc*                  71) 
  900. (defconstant *x-putimage*                     72)
  901. (defconstant *x-getimage*                     73)
  902. (defconstant *x-polytext8*                    74)   
  903. (defconstant *x-polytext16*                   75)   
  904. (defconstant *x-imagetext8*                   76)  
  905. (defconstant *x-imagetext16*                  77)  
  906. (defconstant *x-createcolormap*               78)    
  907. (defconstant *x-freecolormap*                 79) 
  908. (defconstant *x-copycolormapandfree*          80)       
  909. (defconstant *x-installcolormap*              81)  
  910. (defconstant *x-uninstallcolormap*            82)   
  911. (defconstant *x-listinstalledcolormaps*       83)       
  912. (defconstant *x-alloccolor*                   84)
  913. (defconstant *x-allocnamedcolor*              85)    
  914. (defconstant *x-alloccolorcells*              86)   
  915. (defconstant *x-alloccolorplanes*             87)   
  916. (defconstant *x-freecolors*                   88)
  917. (defconstant *x-storecolors*                  89)
  918. (defconstant *x-storenamedcolor*              90)   
  919. (defconstant *x-querycolors*                  91)
  920. (defconstant *x-lookupcolor*                  92)
  921. (defconstant *x-createcursor*                 93)
  922. (defconstant *x-createglyphcursor*            94)    
  923. (defconstant *x-freecursor*                   95)
  924. (defconstant *x-recolorcursor*                96)  
  925. (defconstant *x-querybestsize*                97) 
  926. (defconstant *x-queryextension*               98) 
  927. (defconstant *x-listextensions*               99)
  928. (defconstant *x-setkeyboardmapping*           100)
  929. (defconstant *x-getkeyboardmapping*           101)
  930. (defconstant *x-changekeyboardcontrol*        102)               
  931. (defconstant *x-getkeyboardcontrol*           103)           
  932. (defconstant *x-bell*                         104)
  933. (defconstant *x-changepointercontrol*         105)
  934. (defconstant *x-getpointercontrol*            106)
  935. (defconstant *x-setscreensaver*               107)         
  936. (defconstant *x-getscreensaver*               108)        
  937. (defconstant *x-changehosts*                  109)    
  938. (defconstant *x-listhosts*                    110) 
  939. (defconstant *x-changeaccesscontrol*          111)          
  940. (defconstant *x-changeclosedownmode*          112)
  941. (defconstant *x-killclient*                   113)
  942. (defconstant *x-rotateproperties*          114)
  943. (defconstant *x-forcescreensaver*          115)
  944. (defconstant *x-setpointermapping*            116)
  945. (defconstant *x-getpointermapping*            117)
  946. (defconstant *x-setmodifiermapping*          118)
  947. (defconstant *x-getmodifiermapping*          119)
  948. (defconstant *x-nooperation*                  127)
  949.  
  950. ;;; Some macros for threaded lists
  951.  
  952. (defmacro threaded-atomic-push (item list next type)
  953.   (let ((x (gensym))
  954.     (y (gensym)))
  955.     `(let ((,x ,item))
  956.        (declare (type ,type ,x))
  957.        (loop
  958.      (let ((,y ,list))
  959.        (declare (type (or null ,type) ,y)
  960.             (optimize (speed 3) (safety 0)))
  961.        (setf (,next ,x) ,y)
  962.        (when (conditional-store ,list ,y ,x)
  963.          (return ,x)))))))
  964.  
  965. (defmacro threaded-atomic-pop (list next type)
  966.   (let ((y (gensym)))
  967.     `(loop
  968.        (let ((,y ,list))
  969.      (declare (type (or null ,type) ,y)
  970.           (optimize (speed 3) (safety 0)))
  971.      (if (null ,y)
  972.          (return nil)
  973.        (when (conditional-store ,list ,y (,next (the ,type ,y)))
  974.          (setf (,next (the ,type ,y)) nil)
  975.          (return ,y)))))))
  976.  
  977. (defmacro threaded-nconc (item list next type)
  978.   (let ((first (gensym))
  979.     (x (gensym))
  980.     (y (gensym))
  981.     (z (gensym)))
  982.     `(let ((,z ,item)
  983.        (,first ,list))
  984.        (declare (type ,type ,z)
  985.         (type (or null ,type) ,first)
  986.         (optimize (speed 3) (safety 0)))
  987.        (if (null ,first)
  988.        (setf ,list ,z)
  989.      (do* ((,x ,first ,y)
  990.            (,y (,next ,x) (,next ,x)))
  991.           ((null ,y)
  992.            (setf (,next ,x) ,z)
  993.            ,first)
  994.        (declare (type ,type ,x)
  995.             (type (or null ,type) ,y)))))))
  996.  
  997. (defmacro threaded-push (item list next type)
  998.   (let ((x (gensym)))
  999.     `(let ((,x ,item))
  1000.        (declare (type ,type ,x)
  1001.         (optimize (speed 3) (safety 0)))
  1002.        (shiftf (,next ,x) ,list ,x)
  1003.        ,x)))
  1004.  
  1005. (defmacro threaded-pop (list next type)
  1006.   (let ((x (gensym)))
  1007.     `(let ((,x ,list))
  1008.        (declare (type (or null ,type) ,x)
  1009.         (optimize (speed 3) (safety 0)))
  1010.        (when ,x
  1011.      (shiftf ,list (,next (the ,type ,x)) nil))
  1012.        ,x)))
  1013.  
  1014. (defmacro threaded-enqueue (item head tail next type)
  1015.   (let ((x (gensym)))
  1016.     `(let ((,x ,item))
  1017.        (declare (type ,type ,x)
  1018.         (optimize (speed 3) (safety 0)))
  1019.        (if (null ,tail)
  1020.        (threaded-nconc ,x ,head ,next ,type)
  1021.      (threaded-nconc ,x (,next (the ,type ,tail)) ,next ,type))
  1022.        (setf ,tail ,x))))
  1023.  
  1024. (defmacro threaded-dequeue (head tail next type)
  1025.   (let ((x (gensym)))
  1026.     `(let ((,x ,head))
  1027.        (declare (type (or null ,type) ,x)
  1028.         (optimize (speed 3) (safety 0)))
  1029.        (when ,x
  1030.      (when (eq ,x ,tail)
  1031.        (setf ,tail (,next (the ,type ,x))))
  1032.      (setf ,head (,next (the ,type ,x))))
  1033.        ,x)))
  1034.  
  1035. (defmacro threaded-requeue (item head tail next type)
  1036.   (let ((x (gensym)))
  1037.     `(let ((,x ,item))
  1038.        (declare (type ,type ,x)
  1039.         (optimize (speed 3) (safety 0)))
  1040.        (if (null ,tail)
  1041.        (setf ,tail (setf ,head ,x))
  1042.      (shiftf (,next ,x) ,head ,x))
  1043.        ,x)))
  1044.  
  1045. (defmacro threaded-dolist ((variable list next type) &body body)
  1046.   `(block nil
  1047.      (do* ((,variable ,list (,next (the ,type ,variable))))
  1048.       ((null ,variable))
  1049.        (declare (type (or null ,type) ,variable))
  1050.        ,@body)))
  1051.  
  1052. (defmacro threaded-delete (item list next type)
  1053.   (let ((x (gensym))
  1054.     (y (gensym))
  1055.     (z (gensym))
  1056.     (first (gensym)))
  1057.     `(let ((,x ,item)
  1058.        (,first ,list))
  1059.        (declare (type ,type ,x)
  1060.         (type (or null ,type) ,first)
  1061.         (optimize (speed 3) (safety 0)))
  1062.        (when ,first
  1063.      (if (eq ,first ,x)
  1064.          (setf ,first (setf ,list (,next ,x)))
  1065.        (do* ((,y ,first ,z)
  1066.          (,z (,next ,y) (,next ,y)))
  1067.         ((or (null ,z) (eq ,z ,x))
  1068.          (when (eq ,z ,x)
  1069.            (setf (,next ,y) (,next ,x))))
  1070.          (declare (type ,type ,y))
  1071.          (declare (type (or null ,type) ,z)))))
  1072.        (setf (,next ,x) nil)
  1073.        ,first)))
  1074.  
  1075. (defmacro threaded-length (list next type)
  1076.   (let ((x (gensym))
  1077.     (count (gensym)))
  1078.     `(do ((,x ,list (,next (the ,type ,x)))
  1079.       (,count 0 (index1+ ,count)))
  1080.      ((null ,x)
  1081.       ,count)
  1082.        (declare (type (or null ,type) ,x)
  1083.         (type array-index ,count)
  1084.         (optimize (speed 3) (safety 0))))))
  1085.  
  1086.